Wonky Flux Batch 2019 02

home *** CD-ROM | disk | FTP | other *** search

/ Wonky Flux Batch 2019 02 / Wonky_Flux_Batch_2019-02.zip / Wonky Flux Batch 2019-02 / 090 - CAD Draw.dsk / T.APSOFT II.s < prev next >

Wrap

Text File | 2019-02-17 | 39KB | 1,397 lines

PAG ***************************** * T * * Applesof;PGPPart II * * {{{ * * Copywrite Apple Computer, * * Inc. and Microsoft, Inc.; * * not for publication or * * distribution. * * * ***************************** * * * Formula evaluation, * * Pointer locating, * * & String Handling. * * * * $DD67 - $E79F * * * ***************************** FRMNUM JSR FRMEVL CHKNUM CLC HEX 24 ;Dummy for skip CHKSTR SEC CHKVAL BIT VALTYP BMI CV2 BCS MISMTCH RET12 RTS CV2 BCS RET12 MISMTCH LDX #TYPEMISS-ERRMSG JERROR JMP ERROR * Main formula evalutation routine. * On entry TXTPTR points at 1st chr of formula. FRMEVL >>> DECR.TXTPTR LDX #0 ;Initial preference DFB $24 ;Trick to skip FEVLOOP PHA ;Push last CPRTYP TXA PHA ; and preference LDA #1 JSR CHKMEM ;Check stack ptr >= $38 JSR GETVAL ;Get value or str desc LDA #0 ; at TXTPTR STA CPRTYP FRMEVL2 JSR CHRGOT CPROP SEC SBC #$CF ;> token BCC CHKTYP CMP #3 ;or =, < BGE CHKTYP ;Branch if not CMP #1 ROL EOR #1 EOR CPRTYP ;Set bits of CPRTYP: CMP CPRTYP ; 00000>=< BCC SNTXERR STA CPRTYP JSR CHRGET ;Another operator? JMP CPROP ;Check for <,=,> again CHKTYP LDX CPRTYP BNE COMPARE ;Branch if had <,=,> BCS NOTMATH ;BrasV2 if next token > "<" ADC #$CF-plus BCC NOTMATH ;Branch=\< next token < "+" \u VALTYP ;+ and last result a string? BNXRITH ;Branch if not JMP CAT ;Cr-9atenate if so. ARITH ADC #$FF ;Now A-reg has offset STA INDEX ; from "+". ASL ADC INDEX ;Times 3 TAY PREFTEST PLA ;Get last preferance CMP MATHTBL,Y ;Compare current priority BGE DOMTH ;Do now if preferred JSR CHKNUM ;Was last re@lt a #? N]6AkPHA SAVOP JSR PSHMAD ;Save operation on stack PLA LDY LASTOP BPL PREFNC ;Branch if more formula TAX BEQ GOEX ;Exit if no math in frm BNE DOMATH ;Do last operation COMPARE LSR VALTYP ;Enable string compare TXA ;Set CPRTYP: 0000>=<C ROL ; where C=carry from >>> DECR.TXTPTR ; next character test. LDY #PLUS-MATHTBL ;Force using POSOP for STA CPRTYP ; all three comparisons. BNE PREFTEST ;Always PREFNC CMP MATHTGh,{c:D7YI6r!5+s?YQ'{C@w}HD%vrmi8q?:j#Mf_pjcj qG?D?2\JvdZl`0$lN .D#>|22~?ot address of math LDA MATHTBL+1,Y PHA ;routine on stack. JSR PSHF ;Returns via the JMP (INDEX) LDA CPRTYP JMP FEVLOOP SNTXERR JMP SYNERR PSHF LDA FACSGN ;Get FACSGN to push it LDX MATHTBL,Y * Set INDEX for return and push FAC * A-reg has FACSGN, or -1,0,1 if from STEP PSHFACX TAY ;Called by STEP PLA ;Pull return address STA INDEX ;Place it in INDEX. INC INDEX ;This routine assumes PLA ; return address is not STA INDEX+1 ; on page boundary. TYA PHA ;Push FACSGN PUSHFAC JSR RNDGY*kx T;P8J`qVG@ .Y><^d#X+3 m PUSH.FAC+1 LDA FAC PHA JMP (INDEX) ;Do RTS funny way NOTMATH LDY #$FF ;Set up to exit routine PLA GOEX BEQ EXIT ;Exit if no math to do DOMTH CMP #$64 ;Was it <=>? BEQ DMTH ;Allow string compare if so JSR CHKNUM DMTH STY LASTOP * Pull floating # from stack, place in ARG and go to * math routine via RTS (address was placed on stack): * (Note that <=> routines all go to POSOP.) DOMATH PLA LSR ;Restore carry status STA CPRMASK ; 00000>=< >>> PULL.ARG >>> PULL.ARG+2 >>> PULL.ARG+4 EOR FACSGN STA SGNCPR EXIT LDA FAC ;Go to routine with status RTS ; set by FAC * Get value of variable, function or number following * TXTPTR, or point to string descriptor if a string, * and put in FAC. This also evaluates expressions in * parens by means of a recursive call to FRMEVL. * It is the "kernel" subroutine of FRMEVL: GETVAL LDA #0 STA VALTYP SKIP JSR CHRGET BCS VAR? NUMBER JMP FIN ;If numeric VAR? JSR ISLETC ;A variable? BCS VARL CMP #'.' BEQ NUMBER CMP #minus B^ MIN CMP #plus BEQ SKIP CMP #'"' BNE NOT? STRTXT LDA TXTPTR ;Explicit string, build desc. LDY TXTPTR+1 ADC #0 BCC ST1 INY ST1 JSR STRLIT JMP POINT ;Get pointer to desc. in FAC NOT? CMP #not BNE FN? LDY #UNOT-MATHTBL BNE EQUL ;Always EQUOP LDA OAC ;This routine is called only BNE NOTZ ; by NOT through preceding LDY #1 ; branch to EQUL. HEX 2C ;Trick to skip next instruction NOTZ LDY #0 JMP SNGFLT FN? CMP #fn BNE SGN? JMP FUNCT SGN? CMP #sgn BLT PARCHK JMP UNARY PARCHK JSR CHKOPN ;Is there a '(' at TXTPTR? JSR FRMEVL ;If so, evaluate and CHKCLS LDA #')' ;Check for ')' HEX 2C ;Trick CHKOPN LDA #'(' HEX 2C ;Trick CHKCOM LDA #',' ;Comma at TXTPTR? SYNCHR LDY #0 CMP (TXTPTR),Y BNE SYNERR JMP CHRGET ;If ok, get next chr & return SYNERR LDX #SYNTXERR-ERRMSG JMP ERROR MIN LDY #MINUS-MATHTBL EQUL PLA PLA JMP SAVOP VARL JSR PTRGET STA VPNT STY VPNT+1 LDX VALTYP ;String? BEQ VR1 ;Branch if not LDX #0 STX EXTRAFAC RTS VR1 LDX INTFLG ;Integer var? BPL VR2 ;Branch if not LDY #0 LDA (VPNT),Y ;Get val high TAX INY LDA (VPNT),Y ; and low TAY TXA JMP GIVAYF ;Float it VR2 JMP MOVFM ;Move (A,Y) to FAC SCREEN JSR CHRGET JSR PLOTFNS TXA LDY FIRST JSR SCRN TAY JSR SNGFLT JMP CHKCLS * Process unary operators (functions): UNARY CMP #scrn ;Not unary, do special BEQ SCREEN ASL PHA TAX JSR CHRGET CPX #leftstr*2-1 BLT NOTinstr ;Branch if not an instring op JSR CHKOPN ;Check for '(' JSR FRMEVL ;Process concat., etc. JSR CHKCOM JSR CHKSTR ;Make sure it is a string PLA TAX ;Retrieve routine pointer >>> PUSH.VPNT TXA PHA ;Push it back JSR GETBYT ;Get 1st param in X PLA TAY ;Point Y to routine TXA PHA ;Push 1st param JMP GOROUT ;Go to appropriate string routine NOTinstr JSR PARCHK ;Check syntax & evaluate argument PLA ;Retrieve token*2 TAY GOROUT LDA UNFNC-$A4,Y ;$A4=sgn*2 STA JMPADRS+1 LDA UNFNC-$A3,Y STA JMPADRS+2 JSR JMPADRS ;Does not return for ; LEFT$, RIGHT$, MID$. JMP CHKNUM OR LDA ARG ORA FAC BNE TRUE AND LDA ARG BEQ FALSE LDA FAC BNE TRUE FALSE LDY #0 HEX 2C ;Trick to skip next instruction TRUE LDY #1 JMP SNGFLT * Common routine for <, =, > comparisons: POSOP JSR CHKVAL BCS STRCMP ;Branch if strings LDA ARGSGN ;If ARGSGN + then ORA #$7F ; strip high bit of ARG+1 AND ARG+1 STA ARG+1 LDA #ARG LDY #0 JSR FCOMP ;Return A-reg = -1,0,1 TAX ; as ARG <,=,> FAC JMP NUMCMP STRCMP LDA #0 STA VALTYP DEC CPRTYP ;? JSR FREFAC STA FAC ;String length STX FAC+1 STY FAC+2 LDA ARG+3 LDY ARG+4 JSR FRETMP STX ARG+3 STY ARG+4 TAX ;Len (ARG) string SEC SBC FAC ;Set X to smaller len BEQ SFS LDA #1 BCC SFS LDX FAC LDA #$FF SFS STA FACSGN ;Flag which shorter LDY #$FF INX CMPLOOP INY DEX BNE DOCMP LDX FACSGN ;If = so far, decide by len NUMCMP BMI CMPDONE CLC BCC CMPDONE DOCMP LDA (ARG+3),Y CMP (FAC+1),Y BEQ CMPLOOP LDX #$FF BCS CMPDONE LDX #1 CMPDONE INX ;Convert FF,0,1 to 1,2,4 TXA ROL AND CPRMASK ; 00000>=< BEQ JF ;If no match: false LDA #1 ;At least one match: true JF JMP FLOAT PDL JSR CONINT ;Get # in X (<4 not checked) JSR PREAD ;Read paddle JMP SNGFLT ;Float result NXDIM JSR CHKCOM DIM TAX JSR PTRGET2 ;Creates & zeros array JSR CHRGOT BNE NXDIM RTS PTRGET LDX #0 JSR CHRGOT ;Get variable name PTRGET2 STX DIMFLG ;X has VARNAM if from DIM PTRGET3 STA VARNAM ;Entry from FNC JSR CHRGOT JSR ISLETC ;Is it a letter? BCS NAMOK ;Branch if so BADNAM JMP SYNERR ;Error if not NAMOK LDX #0 STX VALTYP STX INTFLG JMP MORNAM ;To branch across $E000 vectors * BASIC entry points for DOS etc., use: JMP COLDST JMP RESTART BRK MORNAM JSR CHRGET ;2nd chr of variable name BCC GTLT ;Branch if numeric JSR ISLETC ;Is it alpha? BCC STRNG? ;Branch if not GTLT TAX ;Save 2nd chr of name in X BYPASS JSR CHRGET ;Find end of var. name BCC BYPASS ;Loop if numeric JSR ISLETC BCS BYPASS ;or if alpha. STRNG? CMP #'$' ;Set up var type flags BNE INTVAR? LDA #$FF STA VALTYP ;Flag as string BNE NIN ;Always INTVAR? CMP #'%' BNE SCDCH LDA SUBFLG ;Integer var allowed? BMI BADNAM ;Error if not. LDA #$80 STA INTFLG ;Flag as integer ORA VARNAM STA VARNAM ;Set high bit of 1st name chr NIN TXA ORA #$80 ;Set high bit of 2nd name chr TAX JSR CHRGET SCDCH STX VARNAM+1 ;2nd var name chr SEC ORA SUBFLG ;Subscripts allowed SBC #'(' ; and an array? BNE BSB ;Branch if not JARY JMP ARRAY BSB BIT SUBFLG BMI VSEARCH ;Branch if from FOR, DEF or FN BVS JARY ;Branch if called by GETARYPT VSEARCH LDA #0 STA SUBFLG LDA VARTAB ;Init varl pntr LDX VARTAB+1 LDY #0 NXVAR STX LOWTR+1 NV1 STA LOWTR CPX ARYTAB+1 ;End of simple vars? BNE NV2 ;No, go on CMP ARYTAB BEQ NOTFND ;Yes, make one? NV2 LDA VARNAM CMP (LOWTR),Y BNE NXPTR ;Branch if not this one LDA VARNAM+1 INY CMP (LOWTR),Y BEQ SETVPNT ;Branch if found DEY NXPTR CLC LDA LOWTR ADC #7 BCC NV1 INX BNE NX6AR ;Always *@Check if letter A-Z, set carry if o, cleO&p\9u<O I}DIap9Yh ,(A' B, gKr~RXSBC #'[' SEC SBC #$100-'[' ;Get orig. A-reg RTN1 RTS NOTFND PLA ;Get calling adrs low PHA ;Reset stack ptr CMP #VARL+2 ;Called by VARL? BNE NEWVAR ;Branch if not TSX LDA STACK+2,X ;Get calling adrs high CMP #>VARL+2 ;From VARL? BNE NEWVAR ;Branch if not LDA #TWOBRK ;It is not an assignment LDY #>TWOBRK ; so fake va^Jable a#$j[Kfv8Rzk>/_S6-;oVM0,c3!} )20l"C#z4 Move arrays to make room for new variable: NEWVAR >>> TRAY.ARYTAB;LOWTR >>> TRAY.STREND;HIGHTR CLC ADC #7 ;Set for 7 byte move up BCC NWV INY NWV STA HIGHDS ;Set destination adrs STY HIGHDS+1 JSR BLTU ;Do the move LDA HIGHDS LDY HIGHDS+1 INY ;BLTU leaves this 1 too low STA ARYTAB STY ARYTAB+1 LDY #0 LDA VARNAM STA (LOWTR),Y ;Store name of new var INY LDA VARNAM+1 STA (LOWTR),Y LDA #0 ;Set value to 0 LUP 5 INY STA (LOWTR),Y --^ SETVPNT LDA LOWTR CLC ADC #2 LDY LOWTR+1 BCC SVP INY SVP STA VARPNT ;Point to 1st byte of value STY VARPNT+1 RTS GETARY LDA NUMDIM ;Get # of dimensions GETARY2 ASL ; times 2 ADC #5 ; plus 5 (name, offset and #dim) ADC LOWTR ;Add to variable pointer LDY LOWTR+1 BCC GD INY GD STA ARYPNT ;Now points to first descriptor STY ARYPNT+1 ; in array. RTS * Bug: Following # is missing the last (0] byte: NEGNUM HEX 90800@ZP ;=-32768 MAKINT JSR CHRGEhV{SR FRMNUM MKINT LDA FACSGN ;Error if - BMI MI1 AYINT LDA FAC CMP #$90 ;Abs<2^15 ? BCC MI2 ;Branch if so LDA #NEGNUM ;=-2^15 ? LDY #>NEGNUM JSR FCOMP MI1 BNE IQERR ;Error if not MI2 JMP QINT * Routine to locate array element or to create an array. ARRAY LDA SUBFLG ;Subscripts given? BNE FNDARY ;Branch if not LDA DIMFLG ORA INTFLG ;Set high bit if % PHA LDA VALTYP PHA LDY #0 NXTDIM TYA PHA >>> PUSH.VARNAM JSR MAKINT >>> PULL.VARNAM PLA TAY TSX LDA STACK+2,X ;Get VALTYP & INTFLG PHA ; and duplicate LDA STACK+1,X PHA LDA FAC+3 ;Get subscript STA STACK+2,X ; and put on stack where LDA FAC+4 ; VALTYP & INTVLG were STA STACK+1,X INY JSR CHRGOT CMP #',' BEQ NXTDIM ;Loop till all subs put on stack STY NUMDIM JSR CHKCLS >>> PULL.VALTYP ;Retrieve VALTYP & INTFLG AND #$7F ;Mask bit from INTFLG STA DIMFLG ; retrieving DIMFLG FNDARY LDX ARYTAB LDA ARYTAB+1 ARYLOOP STX LOWTR STA LOWTR+1 CMP STREND+1 BNE ARYNAM? CPX STREND BEQ NOTFOUND ARYNAM? LDY #0 LDA (LOWTR),Y ;Get name of array INY CMP VARNAM ;Desired one? BNE NXARY ;Branch if not LDA VARNAM+1 CMP (LOWTR),Y BEQ ARYFOUND NXARY INY LDA (LOWTR),Y CLC ADC LOWTR TAX INY LDA (LOWTR),Y ADC LOWTR+1 BCC ARYLOOP SUBERR LDX #BADSUBS-ERRMSG HEX 2C ;Trick IQERR LDX #ILLQHt-ERRMSG JER JMP ERROR ARYFOUND LDX #REdimARR-ERRMSG LD\IMFLG BNE JER LDA=bBFLG BEQ CHKDIM SEC ;Required by STORETS ;Exit if from GETARYPT CHKDTzJSR GETARY LDA NUMDIM ;Get specified # of dims LDY #4 CMP (LOWTR),Y ;Same as actual #? BNE SUBERR ;Error if not JMP FNDELEM ;Look for specified element NOTFOUND LDA SUBFLG ;From GETARYPT? BEQ MAKARY ;Make new array if not LDX #OSDATA-ERRMV>kJMP ERROR ;Error if so MAKARY JSR GETARY JSR REASON LDA #0 TAY STA STRNG2+1 LDX #5 LDA VARNAM STA (LOWTR),Y BPL NINT DEX ;Integer array NINT INY LDA VARNAM+1 STA (LOWTR),Y BPL RAR ;Branch if real array DEX DEX RAR STX STRNG2 ;X=5,3,2 as: real,str,int LDA NUMDIM INY ;Bypass offset to next array INY ; (to be set later) INY STA (LOWTR),Y SAVDIM LDX #11 ;Default dimension + 1 LDA #0 BIT DIMFLG ;DimensijJHVA,'GUuxcG5RIy4QU I?0 ;}Mc8B&q9ihLfzu 5`K|/a%u_T7f)Ue/r=Mko i2P|aQxlN` ;~~E{# #0 DFLTDIM INY ;Build dim table STA (LOWTR),Y INY TXA STA (LOWTR),Y JSR MULT STX STRNG2 STA STRNG2+1 LDY INDEX ;Retrieve Y saved by MULT DEC NUMDIM ;Count down # dims BNE SAVDIM ;Loop till done ADC ARYPNT+1 ;Point to end of array BCS GME STA ARYPNT+1 TAY TXA ADC ARYPNT BCC ZARY INY BEQ GME ZARY JSR REASON ;Make sure there is room STA STREND ; and then zero out STY STREND+1 ; the array. LDA #0 INC STRNG2+1 LDY STRNG2 BEQ NXPG ZLUU DEY STA (ARYPNT),Y BNE ZLUP NXPG DEFYPz@v?tAzXp{y@G_0(6:~Y DEiTRNG2+1 BNE ZLUP ;Loop till done INC ARYPNT+1 SEC LDA STREND ;Compute offset to next array SBC LOWTR LDY #2 STA (LOWTR),Y ; & place following name LDA STREND+1 INY SBC LOWTR+1 STA (LOWTR),Y LDA DIMFLG ;From DIM? BNE RTN2 ;Branch if so INY FNDELEM LDA (LOWTR),Y ;Find specified element STA NUMDIM ; of array from index put LDA #0 ; on stack by NXTDIM. STA STRNG2 DIMLUP STA STRNG2+1 INY PLA TAX STA FAC+3 ;Retrieve index and PLA ; check against dim. STA FAC+4 CMP (LOWTR),Y BCC DIMOK BNE GSE INY TXA CMP (LOWTR),Y BCC DIMOK2 GSE JMP SUBERR GME JMP MEMERR DIMOK INY DIMOK2 LDA STRNG2+1 ;First time through? ORA STRNG2 CLC BEQ NXDM ;Branch if so JSR MULT ;Compute product of dims TXA ADC FAC+3 TAX TYA LDY INDEX ;Retrieve Y saved by MULT NXDM ADC FAC+4 ;Next dim STX STRNG2 DEC NUMDIM BNE DIMLUP ;Loop till all subs done STA STRNG2+1 LDX #5 LDA VARNAM BPL NINTA ;Branch if not int DEX NINTA LDA VARNAM+1 BPL RARY ;Branch if real DEX DEX R]Y STX RESULT+2 LDA #0 JSR MU1 ;Mult prod of dims by TXA ; size of each entry ADC ARYPNT ;Add array adrs STA VARPNT ; to get final ptr TYA ADC ARYPNT+1 STA VARPNT+1 TAY LDA VARPNT RTN2 RTS * 16 bit (non floating) multiply of (LOWTR),Y * by STRNG2 eeaving product in A,X. * Used only by array subscript routines. MULT STY INDEX ;Save Y to retrieve after RTS LDA (LOWTR),Y STA RESULT+2 DEY LDA (LOWTR),Y MU1 STA RESULT+3 LDA #$10 ;Index for 16 bit mult STA INDX LDX #0 LDY #0 MU2 TXA ;Shift X,Y left one bit ASL TAX TYA ROL TAY BCS GME ;Error if > 16 bit product ASL STRNG2 ;Shift off high bit of ROL STRNG2+1 ; multiplier BCC MU3 ;Branch if bit = 0 CLC TXA ADC RESULT+2 ;Add other multiplier TAX ; to X,Y TYA ADC RESULT+3 TAY BCS GME ;Error if > 16 bit product MU3 DEC INDX BNE MU2 ;Loop till done RTS FRE LDA VALTYP BEQ FRE2 JSR FREFAC FRE2 JSR GARBAG SEC LDA FRETOP SBC STREND TAY LDA FRETOP+1 SBC STREND+1 GIVAYF LDX #0 ;Float signed integer in A,Y STX VALTYP ;Flag as number STA FAC+1 STY FAC+2 LDX #$90 ;DP 16 bits to right JMP FLO1 POS LDY CH SNGFLT LDA #0 SEC BEQ GIVAYF ERRDIR LDX CURLIN+1 INX BNE RTN2 ;Return if deferred mode LDX #ILLDIR-ERRMSG HEX 2C ;Trick UNDFNC LDX #UNDFUNC-ERRMSG JMP ERROR DEF JSR FNC? ;Set up function name varl JSR ERRDIR JSR CHKOPN LDA #$80 STA SUBFLG ;Disallow int vars, etc JSR PTRGET ;Get ptr to argument JSR CHKNUM JSR CHKCLS LDA #equal JSR SYNCHR PHA ;1st chr follg = >>> PUSH.VARPNT >>> PUSH.TXTPTR JSR DATA ;Skip to next statement JMP FNCDATA ;Set up pointers in "value" * A Function Name is a simple variable whose name * has form (neg,pos); its "value" contains: * Pointer to defn * Pointer to argument variable * 1st chr of def FNC? LDA #fn JSR SYNCHR ORA #$80 STA SUBFLG ;Flag as simple variable and JSR PTRGET3 ; set high byte of 1st name chr STA FNCNAM ;Save pointer STY FNCNAM+1 JMP CHKNUM FUNCT JSR FNC? ;Get pointer to func name >>> PUSH.FNCNAM JSR PARCHK ;Evaluate argument (to FAC) JSR CHKNUM >>> PULL.FNCNAM LDY #2 LDA (FNCNAM),Y ;Get pointer to argument STA VARPNT TAX INY LDA (FNCNAM),Y BEQ UNDFNC ;Wasn't defnd if high byte 0 STA VARPNT+1 INY SAVOLD LDA (VARPNT),Y ;Save value of dummy var PHA DEY BPL SAVOLD LDY VARPNT+1 ;Point to val of argument JSR MOVMF ;FAC -> (VARPNT) >>> PUSH.TXTPTR ;Remember position LDA (FNCNAM),Y ;Y=0 STA TXTPTR ;Point to fnc defn INY LDA (FNCNAM),Y STA TXTPTR+1 >>> PUSH.VARPNT JSR FRMNUM ;Evaluate fnc >>> PULL.FNCNAM JSR CHRGOT ;Must be end of stmnt BEQ GETOLD JMP SYNERR GETOLD >>> PULL.TXTPTR ;Retrieve prog position FNCDATA LDY #0 ;Retrieve value of dummy var PLA LUP 4 STA (FNCNAM),Y PLA INY --^ STA (FNCNAM),Y RTS STR JSR CHKNUM ;Make sure it is a number LDY #0 JSR FACSTRNG ;Convert to string in stack PLA PLA LDA #$FF ;Point to STACK-1 to force LDY #0 ; moving string BEQ STRLIT ;Create desc & move string * Create string descriptor: STRINI >>> TRXY.FAC+3 ;DSCPTR STRSPA JSR GETSPA ;A holds length STX FAC+1 ;Save descriptor in FAC STY FAC+2 STA FAC RTS STRLIT LDX #'"' STX CHARAC ;Set up literal STX ENDCHR ; delimiters. STRLT2 STA STRNG1 STY STRNG1+1 STA FAC+1 ;For descriptor STY FAC+2 LDY #$FF FEND INY ;Find end of string LDA (STRNG1),Y BEQ ZEND CMP CHARAC BEQ QUO? CMP ENDCHR BNE FEND QUO? CMP #'"' BEQ NZ ZEND CLC NZ STY FAC ;Length in temp descriptor TYA ADC STRNG1 STA STRNG2 ;Point to string end LDX STRNG1+1 BCC FE1 INX FE1 STX STRNG2+1 LDA STRNG1+1 BEQ FE2 ;Must move string if it is at CMP #2 ; $FF or in input buffer. BNE PUTNEW ;Otherwise just set descriptor FE2 TYA ;Get length in A JSR STRINI ;Make room for string LDX STRNG1 LDY STRNG1+1 JSR MOVSTR ;and move it PUTNEW LDX TEMPPT CPX #TEMPST+9 ;Too many temp descrs? BNE PUTEMP LDX #FORMtoCX-ERRMSG JERR JMP ERROR PUTEMP LDA FAC ;Set up temp descriptor STA 0,X LDA FAC+1 STA 1,X LDA FAC+2 STA 2,X LDY #0 STX FAC+3 STY FAC+4 DEY STY VALTYP ;Flag as string STX LASTPT ;Point to next descriptor INX INX INX STX TEMPPT RTS * Make space for string, length in A: GETSPA LSR GARFLG ;Enable garbage collect GETSPC PHA EOR #$FF SEC ADC FRETOP ;Subtract length from FRETOP LDY FRETOP+1 BCS CY DEY CY CPY STREND+1 BCC FULL ;Branch if no room BNE GOTSPA CMP STREND BCC FULL GOTSPA STA FRETOP STY FRETOP+1 STA FRESPC STY FRESPC+1 TAX PLA RTS FULL LDX #OofMEM-ERRMSG LDA GARFLG ;Garbage done yet? BMI JERR ;Error if so JSR GARBAG LDA #$80 ;Flag garbage done STA GARFLG PLA BNE GETSPC GARBAG LDX MEMSIZ ;Collect from top down LDA MEMSIZ+1 FNDVAR STX FRETOP ;One pass through all vars STA FRETOP+1 ; for each active string! LDY #0 STY FNCNAM+1 ;Flag no collection yet done * Point LOWTR to bottom of string space: >>> TRAX.STREND;LOWTR LDA #TEMPST ;Point to temp LDX #>T%MPST ; string@descriptors STA INDEX STX INDEX+Q TVAR mV#! ;DAfi(9|tjbps? "9j + ;Go to simple vars if so JSR DVAR ;Do a temp BEQ TVAR ;Always taken SVARS LDA #7 STA DSCLEN >>> TRAX.VARTAB;INDEX SVAR CPX ARYTAB+1 ;Simple vars done? BNE SVARGO ;Continue if not CMP ARYTAB BEQ ARYVAR ;Do arrays if so SVARGO JSR DVARS ;Do a simple var BEQ SVAR ;Always taken ARYVAR STA ARYPNT STX ARYPNT+1 LDA #3 Sxb DSCLE$\5"Os86H$_ 3niBVZ$ RV<t,+^-Ri`8_'\F #h{$ sK H76lrays done? BNE ARYVGO ;Do one if not CMP STREND BNE ARYVGO JMP GRBPAS ;All varls checked, move top one ARYVGO STA INDEX STX INDEX+1 LDY #0 LDA (INDEX),Y ;Get array name TAX INY LDA (INDEX),Y PHP ;Save its type INY LDA (INDEX),Y ;Get offset to next array ADC ARYPNT ;Compute adrs STA ARYPNT ;& set pntr to it INY LDA (INDEX),Y ADC ARYPNT+1 STA ARYPNT+1 PLP BPL ARYVA2 ;Branch if not string TXA BMI ARYVA2 ; " INY LDA (INDEX),Y ;Get # of dims LDY #0 ASL ADC #5 >>> BUMP.INDEX ;Point to 1st array element LDX INDEX+1 ARYSTR CPX ARYPNT+1 ;Array done? BNE GOGO ;Do next element if not CMP ARYPNT BEQ ARYVA3 ;Next array if so GOGO JSR DVAR BEQ ARYSTR ;Always taken DVARS LDA (INDEX),Y ;Integer var or func def? BMI DVARTS ;Skip if so INY LDA (INDEX),Y ;String var? BPL DVARTS ;Skip if not INY DVAR LDA (INDEX),Y ;Get length B1Q DVARTS ;Ignore if len }J9NY LDA (INDEX),Y ;Get adrO{4= string TAX INY LDA (INDEX),Y CMP FRETOP+1 BCC DV1 BNE DVARTS CPX FRETOP BCS DVARTS ;Skip if collected already DV1 CMP LOWTR+1 ;Above highest string found? BCC DVARTS ;Skip if not BNE DV2 ;Yes set pointer to it CPX LOWTR BCC DVARTS DV2 STX LOWTR STA LOWTR+1 >>> TRAX.INDEX ;FNCNAM >>> TR.DSCLEN ;LENGTH DVARTS LDA DSCLEN ;Set up for next var CLC >>> BUMP.INDEX VDONE LDX INDEX+1 LDY #0 RTS * Pass through vars done, now move the highest * string found to top and go back for another: * * (Collection ends if FNCNAM+1 is still 0. This means * that an attempt to collect a temp string will abort * collection. This bug is rarely a problem, but could * be if collection is forced by a concatination and the * string space just has room for the new string after * collection. For example: * LOMEM:10000: HIMEM:10012: A$="A":A$=A$+"B":A$=A$+"C": * PRINT A$ gives "ABA".) GRBPAS LDX FNCNAM+1 ;Garbage done? BEQ VDONE ;Yes, return LDA LENGTH AND #4 ;4 if simple, else 0 LSR TAY STA LENGTH ;2 if simple, else 0 >>> AD.(FNCNAM),Y;LOWTR;HIGHTR >>> AD.LOWTR+1 ;#0;HIGHTR+1 >>> TRAX.FRETOP;HIGHDS JSR BLTU2 ;Move string up and LDY LENGTH ; fix its descriptor INY LDA HIGHDS STA (FNCNAM),Y TAX INC HIGHDS+1 LDA HIGHDS+1 INY STA (FNCNAM),Y ;X,A now pot[.s to moved string JMP FNDVAR ;Look for next one to collxV. CAT >>> PUSH.FAC+.aSave 1st desc ptr JSR GETVAL JSR CHKSTOaGet desc ptr to 2nd str >>> PUQtSTRNG1 ;Recover 1st desc ptr LDY #0 LDA (STRNG1),Y ;Add lengths CLC ADC (FAC+3),Y BCC NTL ;Ok if < $100 LDX #STRtoLNG-ERRMSG JMP ERROR NTL JSR STRINI ;Get space for concat str JSR MOVINS ;Move 1st string LDA DSCPTR ;Free the 2Q LDY DSCU-C`1 JSR FRETMP JSR MOVESTR ;Move 2nd string LDA STRNG1 ;Free the 1st LDY STRNG1+1 JSR FRETMP JSR PUTNEW ;Set up desc JMP FRMEVL2 ;Back for more formula MOVINS LDY #0 ;Move str whose desc is at LDA (STRNG1),Y ; (STRNG1) to (FRESPC) PHA ;Length INY LDA (STRNG1),Y TAX ;Put string pointer in X,Y INY LDA (STRNG1),Y TAY PLA ;Retrieve length MOVSTR STX INDEX ;Move string at X,Y STY INDEX+1 ; [at INDEX] to (FRESUgx;ouxUD:1RZqd5#pw_7('@ISg 4i6,RW~t@)>P 5AD[4{:MQ=e.r=]i>g 4#t%m\4Iw_!Z1A-VS2 PLA MVS3 CLC >>> BUMP.FRESPC ;Point FRESPC above string RTS FRESTR JSR CHKSTR ;Last result a string? FREFAC LDA FAC+3 ;Get descriptor pointer LDY FAC+4 FRETMP STA INDEX ;Free temp descriptor STY INDEX+1 ; whose pointer is in (A,Y). JSR FRETMS ;Free descriptor if temp PHP ;Remember if last freed LDY #0 LDA (INDEX),Y PHA ;Push length INY LDA (INDEX),Y TAX ;Get pointer to string in X,Y INY LDA (INDEX),Y TAY PLA ;Retrieve length PLP ; dnd swatus BNE NB ;Branch if not a fre`1\|!Hf3 j`qKPY/c!YU>=ejmthe FA$est string BNE NB ; in memory? CPX FRETOP BNE NB ;Branch if not PHA CLC ;"Delete" string if so >>> BUMP.FRETOP PLA NB STX INDEX ;X,Y hold address of string STY INDEX+1 ; and A holds length. RTS FRETMS CPY LASTPT+1 ;Free temp descriptor BNE RTN3 CMP LASTPT BNE RTN3 STA TEMPPT SBC #3 STA LASTPT LDY #0 RTN3 RTS CHRSTR JSR CONINT ;Convert to byte in X TXA PHA ;Save it LDA #1 ;Get space for string of length 1 JSR STRSPA PLA ;Recall # LDY #0 ;Put in string STA (FAC+1),Y PLA PLA JMP PUTNEW LEFTSTR JSR INSTRNG ;Get parameter I CMP (DSCPTR),Y ;Less than length? TYA ;=0 (index to string start) INS1 BCC INS2 ;Branch if param < length LDA (DSCPTR),Y ;Get length TAX TYA INS2 PHA ;Save index to string start INS3 TXA INS4 PHA ;Save new length JSR STRSPA ;Get space for string LDA DSCPTR LDY DSCPTR+1 JSR FRETMP ;Free temp descriptor PLA ;Get length TAY PLA ;Get string offset CLC ; & add to pointer >>> BUMP.INDEX TYA ;Retrieve length JSR MOVESTR l_ut string in string space JMP PUTNEW RIGHTSTR JSR INSTRNG ;Get parameter I CLC SBC (DSCPTR),Y ; -length-1 EOR #$FF ;Length - I JMP INS1 MIDSTR LDA #$FF ;Set up large fake STA FAC+4 ; 2nd parameter (len) JSR CHRGOT CMP #')' ;2nd param given? BEQ IGS5 ;Branch if not JSR CHKCOM JSR GETBYT ;Get 2nd param in FAC+4 INS5 JSR INSTRNG ;Get 1st param DEX TXA PHA ;Push specified offset CLC LDX #0 SBC (DSCPTR),Y ;-orig len -1 BCS INS3 ;Branch if offset>old len EOR #$FF ;Length of remainder CMP FAC+4 ;< specified length? BCC INS4 ;Branch if so LDA FAC+4 ;Get specified length BCS INS4 ;Always * Common routine for LEFT$, RIGHT$, MID$ to check * for ")", pop return adrs, get descriptor pointer, * and get 1st parameter of command: INSTRNG JSR CHKCLS PLA ;Pull return address TAY ; and save it PLA STA LENGTH PLA ;Pop previous return adrs PLA ; (from GOROUT). PLA ;Retrieve 1st parameter TAX >>> PULL.DSCPTR LDA LENGTH PHA ;Push back return adrs TYA PHA LDY #0 TXA ;Transfer 1st parameter to A BEQ GOIQ ;Error if 0 RTS LEN JSR GETSTR JMP SNGFLT GETSTR JSR FRESTR LDX #0 STX VALTYP TAY ;Holds length RTS ASC JSR GETSTR ;Get string ptr in INDEX BEQ GOIQ ;Error if length 0 LDY #0 LDA (INDEX),Y ;Get 1st chr of string TAY JMP SNGFLT ;Float it GOIQ JMP IQERR GTBYTC JSR CHRGET GETBYT JSR FRMNUM CONINT JSR MKINT LDX FAC+3 ;<256? BNE GOIQ ;Error if not LDX FAC+4 JMP CHRGOT VAL JSR GETSTR ;Get pointer to string in INDEX BNE VL2 JMP ZEROFAC ;Return 0 if length=0 VL2 >>> TRXY.TXTPTR;STRNG2 LDX INDEX STX TXTPTR ;Point TXTPTR to start of string CLC ADC INDEX ;Add length STA DEST ;Point DEST to end of stg + 1 LDX INDEX+1 STX TXTPTR+1 BCC VL3 INX VL3 STX DEST+1 LDY #0 LDA (DEST),Y ;Get byte following string PHA ;Save it LDA #0 STA (DEST),Y ;Put 0 there JSR CHRGOT JSR FIN ;Evaluate string PLA LDY #0 STA (DEST),Y ;Replace byte at end POINT >>> TRXY.STRNG2;TXTPTR RTS GTNUM JSR FRMNUM ;Evaluate syntax: twobyte,byte JSR GETADR ; twobyte -> LINNUM COMBYTE JSR CHKCOM JMP GETBYT ; byte -> X GETADR LDA FAC ;FAC <= $FFFF? CMP #$91 BGE GOIQ ;Error if not. JSR QINT ;Convert to integer LDA FAC+3 ; and move it LDY FAC+4 STY LINNUM ; to LINNUM STA LINNUM+1 RTS PEEK LDA LINNUM ;Protect LINNUM PHA LDA LINNUM+1 PHA JSR GETADR LDY #0 LDA (LINNUM),Y ;Do the PEEK TAY PLA ;Retrieve LINNUM STA LINNUM+1 PLA STA LINNUM JMP SNGFLT ;Float Y POKE JSR GTNUM ;Get byte to POKE in X TXA ; and adrs in LINNUM LDY #0 STA (LINNUM),Y RTS WAIT JSR GTNUM ;Get address in LINNUM STX FORPNT ; & specified mask in FORPNT LDX #0 JSR CHRGOT ;Inversion byte specified? BEQ WT2 ;Branch if not JSR COMBYTE ;Get it WT2 STX FORPNT+1 ;Set up inversion byte LDY #0 WT3 LDA (LINNUM),Y ;Get byte at address EOR FORPNT+1 ;Invert as specified AND FORPNT ;Mask it BEQ WT3 ;Loop till not 0 RTN4 RTS